home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / prog / xms.zip / XMSDEMO.BAS < prev    next >
BASIC Source File  |  1993-03-06  |  4KB  |  145 lines
  1. '*****************************************************************************
  2. ' XMSDEMO.BAS - Simple program to demonstrate XMS interface for QuickBASIC
  3. '               4.0+. May be run on any machine or DOS version.
  4. '
  5. '  (C) Copyright 1993 by One World Software. Placed into the public domain.
  6. '  Author: Robin Duffy
  7. '*****************************************************************************
  8.  
  9. DEFINT A-Z
  10.  
  11. DECLARE FUNCTION XMSError% ()
  12. DECLARE FUNCTION WhichXError% ()
  13. DECLARE FUNCTION GetXMS% (handle%)
  14.  
  15.  
  16. TYPE mydata
  17.    text AS STRING * 40
  18. END TYPE
  19.  
  20. CLS
  21. PRINT "This program demostrates the use of XMS memory with QuickBASIC. All the"
  22. PRINT "major routines are demonstrated here. This simple test program was written"
  23. PRINT "with QuickBASIC version 4.5 and tested in the editing environment."
  24. PRINT
  25. GOSUB keypress
  26. PRINT
  27.  
  28. CALL InitXMS(there, memsize)
  29.  
  30. IF there THEN
  31.    PRINT "This machine has"; memsize * 1024&; "bytes of available XMS!"
  32. ELSE
  33.    PRINT "Sorry, XMS memory is not available."
  34.    END
  35. END IF                                                      'Allocate all of
  36.                                                             'it just to show
  37. handle = GetXMS(memsize)                                    'we can!
  38. IF XMSError THEN
  39.    GOTO errorend
  40. ELSE
  41.    PRINT : PRINT "Successfully allocated"; memsize; "K bytes!"
  42. END IF
  43.  
  44. PRINT : PRINT "Now to create some test data. This test data is a user type array"
  45. PRINT "consisting of one element type - a 40 character string."
  46. GOSUB keypress
  47.  
  48. bytes& = memsize * 1024&                     'Adjust the array size as needed
  49. IF bytes& \ 40 > 400& THEN                   'No telling how much memory!
  50.    numels = 400
  51. ELSE
  52.    numels = bytes& \ 40
  53. END IF
  54.  
  55. REDIM t(1 TO numels) AS mydata
  56.  
  57. FOR x = 1 TO numels
  58.    t(x).text = "This is element number" + STR$(x)
  59.    PRINT t(x).text
  60. NEXT
  61.  
  62. PRINT : PRINT "Saving"; numels; "elements to XMS memory!"
  63.  
  64. CALL Array2XMS(SEG t(1), handle, 40 * numels)
  65. IF XMSError THEN GOTO errorend
  66.  
  67. ERASE t
  68.  
  69. PRINT : PRINT "The data in conventional memory has been erased. Now press a key to"
  70. PRINT "restore the data to a new array and view it."
  71. GOSUB keypress
  72.  
  73. REDIM r(1 TO numels) AS mydata
  74.  
  75. CALL XMS2Array(handle, SEG r(1), 40 * numels)
  76. IF XMSError THEN GOTO errorend
  77.  
  78. FOR x = 1 TO numels
  79.    PRINT r(x).text
  80. NEXT
  81. GOSUB keypress
  82.  
  83. ERASE r
  84. PRINT : PRINT "OK, now you may edit or view any element directly from XMS memory."
  85. PRINT "At the following prompt, press E to edit an element, V to view an element, or"
  86. PRINT "ESC to exit the program. The program will ask you for an element number to"
  87. PRINT "edit. Element numbers run between 1 and"; numels; "inclusive for this demo. "
  88. PRINT "Each element used here is 40 characters long."
  89. GOSUB keypress
  90.  
  91. DIM temp AS mydata
  92.  
  93. DO
  94.    PRINT : PRINT "<E>dit, <V>iew or ESC?"
  95.    DO
  96.       pr$ = UCASE$(INKEY$)
  97.    LOOP UNTIL pr$ = "E" OR pr$ = "V" OR pr$ = CHR$(27)
  98.  
  99.    IF pr$ <> CHR$(27) THEN
  100.       INPUT "Element number? ", element
  101.       IF element < 1 OR element > numels THEN
  102.          PRINT "Invalid element number"
  103.          pr$ = ""
  104.       END IF
  105.    END IF
  106.  
  107.    SELECT CASE pr$
  108.    CASE "E"
  109.       PRINT
  110.       INPUT "New string-> ", temp.text
  111.       CALL XSetElement(handle, temp, 40, element)
  112.       IF XMSError THEN GOTO errorend
  113.   
  114.    CASE "V"
  115.       PRINT : PRINT "Element"; element; "is: ";
  116.       CALL XGetElement(handle, temp, 40, element)
  117.       IF XMSError THEN GOTO errorend
  118.       PRINT temp.text
  119.   
  120.    END SELECT
  121.  
  122. LOOP UNTIL pr$ = CHR$(27)
  123.  
  124.  
  125. CALL FreeXMS(handle)
  126.  
  127. PRINT : PRINT "XMS memory has been released!"
  128. PRINT : PRINT "This concludes the XMS demo program."
  129. END
  130.  
  131. errorend:
  132.    PRINT : PRINT "Error"; WhichXError; "occured - aborting program."
  133.    PRINT "See program documentation for error information."
  134.   
  135.    IF handle THEN                             'Release it if it was allocated
  136.       CALL FreeXMS(handle)                    'as DOS will not.
  137.    END IF
  138.   
  139.    END
  140.  
  141. keypress:
  142.    PRINT "Press any key to continue..."
  143.    WHILE INKEY$ = "": WEND
  144.    RETURN
  145.